home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / autobox.pm next >
Encoding:
Perl POD Document  |  2010-03-17  |  13.3 KB  |  401 lines

  1. package autobox;
  2.  
  3. use 5.008;
  4.  
  5. use strict;
  6. use warnings;
  7.  
  8. use Carp;
  9. use XSLoader;
  10. use Scalar::Util;
  11. use Scope::Guard;
  12. use Storable;
  13.  
  14. our $VERSION = '2.70';
  15.  
  16. XSLoader::load 'autobox', $VERSION;
  17.  
  18. use autobox::universal (); # don't import
  19.  
  20. ############################################# PRIVATE ###############################################
  21.  
  22. my $SEQ            = 0;  # unique identifier for synthetic classes
  23. my $BINDINGS_CACHE = {}; # hold a reference to the bindings hashes
  24. my $CLASS_CACHE    = {}; # reuse the same synthetic class if the @isa has been seen before
  25.  
  26. # all supported types
  27. # the boolean indicates whether the type is a real internal type (as opposed to a virtual type)
  28. my %TYPES = (
  29.     UNDEF     => 1,
  30.     INTEGER   => 1,
  31.     FLOAT     => 1,
  32.     NUMBER    => 0,
  33.     STRING    => 1,
  34.     SCALAR    => 0,
  35.     ARRAY     => 1,
  36.     HASH      => 1,
  37.     CODE      => 1,
  38.     UNIVERSAL => 0
  39. );
  40.  
  41. # type hierarchy: keys are parents, values are (depth, children) pairs
  42. my %ISA = (
  43.     UNIVERSAL => [ 0, [ qw(SCALAR ARRAY HASH CODE) ] ],
  44.     SCALAR    => [ 1, [ qw(STRING NUMBER) ] ],
  45.     NUMBER    => [ 2, [ qw(INTEGER FLOAT) ] ]
  46. );
  47.  
  48. # default bindings when no args are supplied
  49. my %DEFAULT = (
  50.     SCALAR => 'SCALAR',
  51.     ARRAY  => 'ARRAY',
  52.     HASH   => 'HASH',
  53.     CODE   => 'CODE'
  54. );
  55.  
  56. # reinvent List::MoreUtils::uniq to keep the dependencies light - return a reference
  57. # to an array containing (in order) the unique members of the supplied list
  58. sub _uniq($) {
  59.     my $list = shift;
  60.     my (%seen, @uniq);
  61.  
  62.     for my $element (@$list) {
  63.         next if ($seen{$element});
  64.         push @uniq, $element;
  65.         $seen{$element} = 1;
  66.     }
  67.  
  68.     return [ @uniq ];
  69. }
  70.  
  71. # create a shim class - actual methods are implemented by the classes in its @ISA
  72. #
  73. # as an optimization, return the previously-generated class
  74. # if we've seen the same (canonicalized) @isa before
  75. sub _generate_class($) {
  76.     my $isa = _uniq(shift);
  77.  
  78.     # As an optimization, simply return the class if there's only one.
  79.     # This speeds up method lookup as the method can (often) be found directly in the stash
  80.     # rather than in the ISA hierarchy with its attendant AUTOLOAD-related overhead
  81.     if (@$isa == 1) {
  82.         my $class = $isa->[0];
  83.         _make_class_accessor($class); # nop if it's already been universalized
  84.         return $class;
  85.     }
  86.  
  87.     my $key = Storable::freeze($isa);
  88.  
  89.     return $CLASS_CACHE->{$key} ||= do {
  90.         my $class = sprintf('autobox::_shim_%d_', ++$SEQ);
  91.         my $synthetic_class_isa = _get_isa($class); # i.e. autovivify
  92.  
  93.         @$synthetic_class_isa = @$isa;
  94.         _make_class_accessor($class);
  95.         $class;
  96.     };
  97. }
  98.  
  99. # expose the autobox class (for can, isa &c.)
  100. # https://rt.cpan.org/Ticket/Display.html?id=55565
  101. sub _make_class_accessor ($) {
  102.     my $class = shift;
  103.     return unless (defined $class);
  104.     {
  105.         no strict 'refs';
  106.         *{"$class\::autobox_class"} = sub { $class } unless (*{"$class\::autobox_class"}{CODE});
  107.     }
  108. }
  109.  
  110. # pretty-print the bindings hash by showing its values as the inherited classes rather than the synthetic class
  111. sub _pretty_print($) {
  112.     my $hash = { %{ shift() } }; # clone the hash to isolate it from the original
  113.  
  114.     # reverse() turns a hash that maps an isa signature to a class name into a hash that maps
  115.     # a class name into a boolean
  116.     my %synthetic = reverse(%$CLASS_CACHE);
  117.  
  118.     for my $type (keys %$hash) {
  119.         my $class = $hash->{$type};
  120.         $hash->{$type} = $synthetic{$class} ? [ _get_isa($class) ] : [ $class ];
  121.     }
  122.  
  123.     return $hash;
  124. }
  125.  
  126. # default sub called when the DEBUG option is supplied with a true value
  127. # prints the assigned bindings for the current scope
  128. sub _debug ($) {
  129.     my $bindings = shift;
  130.     require Data::Dumper;
  131.     no warnings qw(once);
  132.     local ($|, $Data::Dumper::Indent, $Data::Dumper::Terse, $Data::Dumper::Sortkeys) = (1, 1, 1, 1);
  133.     print STDERR Data::Dumper::Dumper($bindings), $/;
  134. }
  135.  
  136. # return true if $ref ISA $class - works with non-references, unblessed references and objects
  137. # we can't use UNIVERSAL::isa to test if a value is an array ref;
  138. # if the value is 'ARRAY', and that package exists, then UNIVERSAL::isa('ARRAY', 'ARRAY') is true!
  139. sub _isa($$) {
  140.     my ($ref, $class) = @_;
  141.     return Scalar::Util::blessed($ref) ? $ref->isa($class) : ref($ref) eq $class;
  142. }
  143.  
  144. # get/autovivify the @ISA for the specified class
  145. sub _get_isa($) {
  146.     my $class = shift;
  147.     my $isa   = do {
  148.         no strict 'refs';
  149.         *{"$class\::ISA"}{ARRAY};
  150.     };
  151.     return wantarray ? @$isa : $isa;
  152. }
  153.  
  154. # install a new set of bindings for the current scope
  155. #
  156. # XXX this could be refined to reuse the same hashref if its contents have already been seen,
  157. # but that requires each (frozen) hash to be cached; at best, it may not be much of a win, and at
  158. # worst it will increase bloat
  159. sub _install ($) {
  160.     my $bindings = shift;
  161.     $^H{autobox} = $bindings;
  162.     $BINDINGS_CACHE->{$bindings} = $bindings; # keep the $bindings hash alive
  163. }
  164.  
  165. # return the supplied class name or a new class name made by appending the specified
  166. # type to the namespace prefix
  167. sub _expand_namespace($$) {
  168.     my ($class, $type) = @_;
  169.  
  170.     # make sure we can weed out classes that are empty strings or undef by returning an empty list
  171.     Carp::confess("_expand_namespace not called in list context") unless (wantarray);
  172.  
  173.     if ((defined $class) && ($class ne '')) {
  174.         ($class =~ /::$/) ? "$class$type" : $class;
  175.     } else { # return an empty list
  176.         ()
  177.     }
  178. }
  179.  
  180. ############################################# PUBLIC (Methods) ###############################################
  181.  
  182. # enable some flavour of autoboxing in the current scope
  183. sub import {
  184.     my ($class, %args) = @_;
  185.     my $debug = delete $args{DEBUG};
  186.  
  187.     %args = %DEFAULT unless (%args); # wait till DEBUG has been deleted
  188.  
  189.     # normalize %args so that it has a (possibly empty) array ref for all types, both real and virtual
  190.     for my $type (keys %TYPES) {
  191.         if (exists $args{$type}) { # exists() as the value may be undef (or ''), meaning "don't default this type"
  192.             if (_isa($args{$type}, 'ARRAY')) {
  193.                 $args{$type} = [ @{$args{$type}} ]; # clone the array ref to isolate changes
  194.             } else {
  195.                 $args{$type} = [ $args{$type} ];
  196.             }
  197.         } else {
  198.             $args{$type} = [];
  199.         }
  200.     }
  201.  
  202.     # if supplied, fill in defaults for unspecified SCALAR, ARRAY, HASH and CODE bindings
  203.     # must be done before the virtual type expansion below as one of the defaults, SCALAR, is a
  204.     # virtual type
  205.  
  206.     my $default = delete $args{DEFAULT};
  207.  
  208.     if ($default) {
  209.         $default = [ $default ] unless (_isa($default, 'ARRAY')); # no need to clone as we flatten it each time
  210.  
  211.         for my $type (keys %DEFAULT) {
  212.             # don't default if a binding has already been supplied; this may include an undef value meaning
  213.             # "don't default this type" e.g.
  214.             #
  215.             #     use autobox
  216.             #         DEFAULT => 'MyDefault',
  217.             #         HASH    => undef;
  218.             #
  219.             # undefs are winnowed out by _expand_namespace
  220.  
  221.             next if (@{$args{$type}}); 
  222.             push @{$args{$type}}, map { _expand_namespace($_, $type) } @$default;
  223.         }
  224.     }
  225.  
  226.     # expand the virtual type "macros" from the root to the leaves
  227.     for my $vtype (sort { $ISA{$a}->[0] <=> $ISA{$b}->[0] } keys %ISA) {
  228.         next unless ($args{$vtype});
  229.  
  230.         my @types = @{$ISA{$vtype}->[1]};
  231.  
  232.         for my $type (@types) {
  233.             if (_isa($args{$vtype}, 'ARRAY')) {
  234.                 push @{$args{$type}}, map { _expand_namespace($_, $vtype) } @{$args{$vtype}};
  235.             } else {
  236.                 # _expand_namespace returns an empty list if $args{$vtype} is undef (or '')
  237.                 push @{$args{$type}}, _expand_namespace($args{$vtype}, $vtype);
  238.             }
  239.         }
  240.  
  241.         delete $args{$vtype};
  242.     }
  243.  
  244.     my $bindings; # custom typemap
  245.  
  246.     # clone the bindings hash if available
  247.     #
  248.     # we may be assigning to it, and we don't want to contaminate outer/previous bindings
  249.     # with nested/new bindings
  250.     #
  251.     # as of 5.10, references in %^H get stringified at runtime, but we don't need them then
  252.  
  253.     $bindings = $^H{autobox} ? { %{ $^H{autobox} } } : {};
  254.  
  255.     # sanity check %args, expand the namespace prefixes into class names,
  256.     # and copy values to the $bindings hash
  257.  
  258.     my %synthetic = reverse (%$CLASS_CACHE); # synthetic class name => bool - see _pretty_print
  259.  
  260.     for my $type (keys %args) {
  261.         # we've handled the virtual types, so we only need to check that this is a valid (real) type
  262.         Carp::confess("unrecognized option: '", (defined $type ? $type : '<undef>'), "'") unless ($TYPES{$type});
  263.  
  264.         my (@isa, $class);
  265.        
  266.         if ($class = $bindings->{$type}) {
  267.             @isa = $synthetic{$class} ? _get_isa($class) : ($class);
  268.         }
  269.  
  270.         # perform namespace expansion; dups are removed in _generate_class below
  271.         push @isa, map { _expand_namespace($_, $type) } @{$args{$type}};
  272.  
  273.         $bindings->{$type} = [ @isa ]; # assign the (possibly) new @isa for this type
  274.     }
  275.  
  276.     # replace each array ref of classes with the name of the generated class.
  277.     # if there's only one class in the type's @ISA (e.g. SCALAR => 'MyScalar') then
  278.     # that class is used; otherwise a shim class whose @ISA contains the two or more classes
  279.     # is created 
  280.  
  281.     for my $type (keys %$bindings) {
  282.         my $isa = $bindings->{$type};
  283.  
  284.         # delete empty arrays e.g. use autobox SCALAR => []
  285.         if (@$isa == 0) {
  286.             delete $bindings->{$type};
  287.         } else {
  288.             # associate the synthetic/single class with the specified type
  289.             $bindings->{$type} = _generate_class($isa); 
  290.         }
  291.     }
  292.  
  293.     # This turns on autoboxing i.e. the method call checker sets a flag on the method call op
  294.     # and replaces its default handler with the autobox implementation.
  295.     #
  296.     # It needs to be set unconditionally because it may have been unset in unimport
  297.  
  298.     $^H |= 0x120000; # set HINT_LOCALIZE_HH + an unused bit to work around a %^H bug
  299.  
  300.     # install the specified bindings in the current scope
  301.     _install($bindings);
  302.  
  303.     # this is %^H as an integer - it changes as scopes are entered/exited
  304.     # we don't need to stack/unstack it in %^H as %^H itself takes care of that
  305.     # note: we need to call this *after* %^H is referenced (and possibly created) above
  306.  
  307.     my $scope = _scope();
  308.     my $old_scope = exists($^H{autobox_scope})? $^H{autobox_scope} : 0;
  309.     my $new_scope; # is this a new (top-level or nested) scope?
  310.  
  311.     if ($scope == $old_scope) {
  312.         $new_scope = 0;
  313.     } else {
  314.         $^H{autobox_scope} = $scope;
  315.         $new_scope = 1;
  316.     }
  317.  
  318.     # warn "OLD ($old_scope) => NEW ($scope): $new_scope ", join(':', (caller(1))[0 .. 2]), $/;
  319.  
  320.     if ($debug) {
  321.         $debug = \&_debug unless (_isa($debug, 'CODE'));
  322.         $debug->(_pretty_print($bindings));
  323.     }
  324.  
  325.     return unless ($new_scope);
  326.  
  327.     # This sub is called when this scope's $^H{autobox_leave} is deleted, usually when
  328.     # %^H is destroyed at the end of the scope, but possibly directly in unimport()
  329.     #
  330.     # _enter splices in the autobox method call checker and method call op
  331.     # if they're not already enabled
  332.     #
  333.     # _leave performs the necessary housekeeping to ensure that the default
  334.     # checker and op are restored when autobox is no longer in scope
  335.  
  336.     my $guard = Scope::Guard->new(sub { _leave() });
  337.     $^H{autobox_leave} = $guard;
  338.  
  339.     _enter();
  340. }
  341.  
  342. # delete one or more bindings; if none remain, disable autobox in the current scope
  343. #
  344. # note: if bindings remain, we need to create a new hash (initially a clone of the current
  345. # hash) so that the previous hash (if any) is not contaminated by new deletions(s)
  346. #
  347. #   use autobox;
  348. #
  349. #       "foo"->bar;
  350. #
  351. #   no autobox qw(SCALAR); # don't clobber the default bindings for "foo"->bar
  352. #
  353. # however, if there are no more bindings we can remove all traces of autobox from the
  354. # current scope.
  355.  
  356. sub unimport {
  357.     my ($class, @args) = @_;
  358.  
  359.     # the only situation in which there is no bindings hash is if this is a "no autobox"
  360.     # that precedes any "use autobox", in which case we don't need to turn autoboxing off as it's
  361.     # not yet been turned on
  362.     return unless ($^H{autobox});
  363.  
  364.     my $bindings;
  365.  
  366.     if (@args) {
  367.         $bindings = { %{$^H{autobox}} }; # clone the current bindings hash
  368.         my %args = map { $_ => 1 } @args;
  369.  
  370.         # expand any virtual type "macros"
  371.         for my $vtype (sort { $ISA{$a}->[0] <=> $ISA{$b}->[0] } keys %ISA) {
  372.             next unless ($args{$vtype});
  373.  
  374.             # we could delete the types directly from $bindings here, but we may as well pipe them
  375.             # through the option checker below to ensure correctness
  376.             $args{$_} = 1 for (@{$ISA{$vtype}->[1]});
  377.  
  378.             delete $args{$vtype};
  379.         }
  380.  
  381.         for my $type (keys %args) {
  382.             # we've handled the virtual types, so we only need to check that this is a valid (real) type
  383.             Carp::confess("unrecognized option: '", (defined $type ? $type : '<undef>'), "'") unless ($TYPES{$type});
  384.             delete $bindings->{$type};
  385.         }
  386.     } else { # turn off autoboxing
  387.         $bindings = {}; # empty hash to trigger full deletion below
  388.     }
  389.  
  390.     if (%$bindings) {
  391.         _install($bindings);
  392.     } else { # remove all traces of autobox from the current scope
  393.         $^H &= ~0x120000; # unset HINT_LOCALIZE_HH + the additional bit
  394.         delete $^H{autobox};
  395.         delete $^H{autobox_scope};
  396.         delete $^H{autobox_leave}; # triggers the leave handler
  397.     }
  398. }
  399.  
  400. 1;
  401.